{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies #-}
module Data.TreeLike where

import Data.Tree
import Data.Maybe
import Data.EitherLike
import Data.PairLike
import Data.Monoid

class (Eq l) => TreeLike t l e | t -> e, t -> l where
        tlnull        :: t -> Bool
        branch        :: t -> l -> t -> t
        leaf          :: t -> e -> t
        tlempty       :: t
        tlappend      :: t -> t -> t
        tlsingleLeaf  :: e -> t
        tlsingleBranch:: l -> t -> t
        tlmap         :: (TreeLike t1 l1 e1)=> (e -> e1) -> (l -> l1) -> t -> t1
        tlmapl        :: (TreeLike t1 l1 e1)=> (l -> e -> e1) -> (l -> l1) -> l -> t -> t1
        toTreeLike    :: (TreeLike t1 l e) => t -> t1
        fromTreeLike  :: (TreeLike t1 l e) => t1 -> t
        tlhead        :: t -> Either e (l,t)
        tltail        :: t -> t
        tlunCons      :: t -> (Either e (l,t),t)
        tlcons        :: Either e (l,t) -> t -> t
        tlconsLeaf    :: e -> t -> t
        tlconsBranch  :: l -> t -> t -> t
        tlfirstLeaf   :: t -> Maybe e
        tlfirstBranch :: l -> t -> Maybe t
        branch tree label subtree = tree `tlappend` tlsingleBranch label subtree
        leaf tree elem = tree `tlappend` tlsingleLeaf elem
        tlappend tree0 tree1 | tlnull tree1 = tree0
                             | tlnull tree0 = tree1
                             | otherwise = let (hd,tl) = tlunCons tree0 in
                                           tlcons hd $ tlappend tl tree1
        tlsingleLeaf elem = tlconsLeaf elem tlempty
        tlsingleBranch label sub = tlconsBranch label sub tlempty
        tlmap fe fl tree | tlnull tree = tlempty
                         | otherwise =
                                   let apply tree = tlmap fe fl tree in
                                   case (tlunCons tree) of
                                        (Left elem,rest) ->
                                                tlconsLeaf (fe elem) $ apply rest
                                        (Right (lb,br), rest) ->
                                                tlconsBranch (fl lb) (apply br) (apply rest)
        tlmapl fle fl rl tree | tlnull tree = tlempty
                              | otherwise =
                                   let apply rl tree = tlmapl fle fl rl tree
                                       fe = fle rl
                                   in
                                   case (tlunCons tree) of
                                        (Left elem,rest) ->
                                                tlconsLeaf (fe elem) $ apply rl rest
                                        (Right (lb,br), rest) ->
                                                tlconsBranch (fl lb) (apply lb br) (apply rl rest)

        toTreeLike = tlmap id id
        fromTreeLike = tlmap id id
        tlhead = fst . tlunCons
        tltail = snd . tlunCons
        tlunCons tree = (tlhead tree,tltail tree)
        tlcons (Left elem) rest = tlconsLeaf elem rest
        tlcons (Right (label,sub)) rest = tlconsBranch label sub rest
        tlconsLeaf elem rest = tlcons (Left elem) rest
        tlconsBranch label sub rest = tlcons (Right (label,sub)) rest
        tlfirstLeaf tree | tlnull tree = Nothing
                         | otherwise = case (tlhead tree) of
                                            Left elem -> Just elem
                                            Right (_,_) -> tlfirstLeaf (tltail tree)
        tlfirstBranch label tree | tlnull tree = Nothing
                                 | otherwise = case (tlhead tree) of
                                                    Left _ -> tlfirstBranch label (tltail tree)
                                                    Right (l1,br) | l1 == label -> Just br
                                                                  | otherwise ->  tlfirstBranch label (tltail tree)

        -- minimal definition:
        -- tlnull (assuming tlnull tlempty = True)
        -- tlempty (assuming tlnull tlempty = True, tlappend tlempty t = t, tlappend t tlempty = t)
        -- tlcons OR (tlconsLeaf AND tlconsBranch)
        -- tlunCons OR (tlhead AND tltail)
        --



instance PairLike a [Tree a] (Tree a) where
        toPair (Node x y) = (x,y)
        fromPair (x,y) = Node x y

-- a strange instance, isn't it?))
instance EitherLike a (Tree a) (Tree a) where
        toEither (Node x []) = Left x
        toEither (Node x y) = Right $ Node x y
        left x = Node x []
        right y = y

instance (Eq a)=> TreeLike ([Tree a]) a a where
        tlempty = []
        tlnull = null
        tlconsLeaf el tr = Node el [] : tr
        tlconsBranch lb sub tr = Node lb sub : tr
        tlhead [] = error "tlhead called on empty list"
        tlhead (h:_) = mapEitherLikes id toPair h
        tltail = tail
